home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / derf.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  3.2 KB  |  70 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((nterf 0)
  12.       (xbig 0.0)
  13.       (sqeps 0.0)
  14.       (erfcs (make-array 21 :element-type 'double-float))
  15.       (sqrtpi 1.772453850905516)
  16.       (first nil))
  17.   (declare (type f2cl-lib:logical first)
  18.            (type (simple-array double-float (21)) erfcs)
  19.            (type double-float sqrtpi sqeps xbig)
  20.            (type f2cl-lib:integer4 nterf))
  21.   (f2cl-lib:fset (f2cl-lib:fref erfcs (1) ((1 21))) -0.04904612123469181)
  22.   (f2cl-lib:fset (f2cl-lib:fref erfcs (2) ((1 21))) -0.14226120510371365)
  23.   (f2cl-lib:fset (f2cl-lib:fref erfcs (3) ((1 21))) 0.010035582187599796)
  24.   (f2cl-lib:fset (f2cl-lib:fref erfcs (4) ((1 21))) -5.768764699767486e-4)
  25.   (f2cl-lib:fset (f2cl-lib:fref erfcs (5) ((1 21))) 2.7419931252196067e-5)
  26.   (f2cl-lib:fset (f2cl-lib:fref erfcs (6) ((1 21))) -1.1043175507344509e-6)
  27.   (f2cl-lib:fset (f2cl-lib:fref erfcs (7) ((1 21))) 3.8488755420345033e-8)
  28.   (f2cl-lib:fset (f2cl-lib:fref erfcs (8) ((1 21))) -1.1808582533875464e-9)
  29.   (f2cl-lib:fset (f2cl-lib:fref erfcs (9) ((1 21))) 3.233421582605091e-11)
  30.   (f2cl-lib:fset (f2cl-lib:fref erfcs (10) ((1 21))) -7.991015947004547e-13)
  31.   (f2cl-lib:fset (f2cl-lib:fref erfcs (11) ((1 21))) 1.7990725113961456e-14)
  32.   (f2cl-lib:fset (f2cl-lib:fref erfcs (12) ((1 21))) -3.7186354878186934e-16)
  33.   (f2cl-lib:fset (f2cl-lib:fref erfcs (13) ((1 21))) 7.103599003714253e-18)
  34.   (f2cl-lib:fset (f2cl-lib:fref erfcs (14) ((1 21))) -1.2612455119155225e-19)
  35.   (f2cl-lib:fset (f2cl-lib:fref erfcs (15) ((1 21))) 2.0916406941769294e-21)
  36.   (f2cl-lib:fset (f2cl-lib:fref erfcs (16) ((1 21))) -3.2539731029314073e-23)
  37.   (f2cl-lib:fset (f2cl-lib:fref erfcs (17) ((1 21))) 4.7668672097976744e-25)
  38.   (f2cl-lib:fset (f2cl-lib:fref erfcs (18) ((1 21))) -6.598012078285136e-27)
  39.   (f2cl-lib:fset (f2cl-lib:fref erfcs (19) ((1 21))) 8.655011469963763e-29)
  40.   (f2cl-lib:fset (f2cl-lib:fref erfcs (20) ((1 21))) -1.0788925177498063e-30)
  41.   (f2cl-lib:fset (f2cl-lib:fref erfcs (21) ((1 21))) 1.2811883993017004e-32)
  42.   (setq first f2cl-lib:%true%)
  43.   (defun derf (x)
  44.     (declare (type double-float x))
  45.     (prog ((y 0.0) (derf 0.0))
  46.       (declare (type double-float derf y))
  47.       (cond
  48.        (first
  49.         (setf nterf
  50.                 (initds erfcs 21
  51.                  (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3)))))
  52.         (setf xbig
  53.                 (f2cl-lib:fsqrt
  54.                  (- (f2cl-lib:flog (* sqrtpi (f2cl-lib:d1mach 3))))))
  55.         (setf sqeps (f2cl-lib:fsqrt (* 2.0 (f2cl-lib:d1mach 3))))))
  56.       (setf first f2cl-lib:%false%)
  57.       (setf y (coerce (abs x) 'double-float))
  58.       (if (> y 1.0) (go label20))
  59.       (if (<= y sqeps) (setf derf (/ (* 2.0 x x) sqrtpi)))
  60.       (if (> y sqeps)
  61.           (setf derf (* x (+ 1.0 (dcsevl (- (* 2.0 x x) 1.0) erfcs nterf)))))
  62.       (go end_label)
  63.      label20
  64.       (if (<= y xbig) (setf derf (f2cl-lib:sign (- 1.0 (derfc y)) x)))
  65.       (if (> y xbig) (setf derf (f2cl-lib:sign 1.0 x)))
  66.       (go end_label)
  67.      end_label
  68.       (return (values derf nil)))))
  69.  
  70.